home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / lists.c < prev    next >
C/C++ Source or Header  |  1993-07-18  |  10KB  |  462 lines
  1. /* ******************************************************************** */
  2. /* lists.c           Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* basic list operations                                        */
  5. /* ******************************************************************** */
  6.  
  7. #define JMPDBG(x)
  8.  
  9. /*
  10.  * Change Log:
  11.  *   Version 1, March 1990 (Compiler rationalisation)
  12.  *     Verified GC proof.
  13.  */
  14.  
  15. #include <string.h>
  16. #include "funcalls.h"
  17. #include "defs.h"
  18. #include "structs.h"
  19. #include "error.h"
  20. #include "global.h"
  21.  
  22. #include "allocate.h"
  23. #include "modboot.h"
  24. #include "calls.h"
  25. #include "modules.h"
  26.  
  27. EUFUN_1( Fn_consp, form)
  28. {
  29.   return (is_cons(form) ? lisptrue : nil);
  30. }
  31. EUFUN_CLOSE
  32.  
  33. EUFUN_1( Fn_car, x)
  34. {
  35.  
  36.   while (TRUE) {
  37.     if (is_cons(x)) return (x->CONS).car;
  38.                 /* Illegal car; needs to act on signals */
  39.                 /* Until that is fixed just stop        */
  40.     x = CallError(stacktop,"car: not a list",x,CONTINUABLE);
  41.   }
  42.  
  43.   return(nil); /* dummy */
  44. }
  45. EUFUN_CLOSE
  46.  
  47. EUFUN_2( car_updator,  x, y)
  48. {
  49.   while (!is_cons(x))
  50.     x = CallError(stacktop,"car_updator: attempt to rplaca into atom", x,
  51.           CONTINUABLE);
  52.   (x->CONS).car = y;
  53.   return y;
  54. }
  55. EUFUN_CLOSE
  56.  
  57. EUFUN_1( Fn_cdr, x)
  58. {
  59.  
  60.   while (TRUE) {
  61.     if (is_cons(x)) return (x->CONS).cdr;
  62.                 /* Illegal car; needs to act on signals */
  63.                 /* Until that is fixed just stop        */
  64.     x = CallError(stacktop,"cdr: not a list",x,CONTINUABLE);
  65.   }
  66.  
  67.   return(nil); /* dummy */
  68. }
  69. EUFUN_CLOSE
  70.  
  71. EUFUN_2( cdr_updator,  x, y)
  72. {
  73.   while (!is_cons(x))
  74.     x = CallError(stacktop,"cdr_updator: attempt to rplacd into atom", x,
  75.           CONTINUABLE);
  76.   (x->CONS).cdr = y;
  77.   return y;
  78. }
  79. EUFUN_CLOSE
  80.  
  81.                 /* Length of a list; does not check */
  82. EUFUN_1( Fn_length, form)
  83. {
  84.   int i = 0;
  85.  
  86.   while (is_cons(form)) {
  87.     i++;
  88.     form = CDR(form);
  89.   }
  90.   return allocate_integer(stacktop,i);
  91. }
  92. EUFUN_CLOSE
  93.  
  94. EUFUN_1( Fn_list, ll)
  95. {
  96.   /* Say, wow!! Declaring this n-ary gives us it for free... */
  97.  
  98.   return(ll);
  99. }
  100. EUFUN_CLOSE
  101.  
  102. /*     
  103.   * Other list functions
  104.   *
  105.  */
  106. LispObject flat_list_copy(LispObject *);
  107.  
  108. EUFUN_1( Fn_null, form)
  109. {
  110.   return (form==nil?lisptrue:nil);
  111. }
  112. EUFUN_CLOSE
  113.  
  114.                 /* Destructive append */
  115. EUFUN_2( Fn_nconc,  form1, form2)
  116. {
  117.   LispObject p = form1;
  118.   if (!is_cons(form1)) return(form2);
  119.   while (CDR(p)!=nil) p = CDR(p);
  120.   CDR(p) = form2;
  121.   return form1;
  122. }
  123. EUFUN_CLOSE
  124.  
  125. EUFUN_2( Fn_append,  l1, l2)
  126. {
  127.   LispObject endptr,walker,val;
  128.  
  129.   if (!is_cons(l1)) return(l2);
  130.  
  131.   /* reasonable append */
  132.   
  133.   val = EUCALL_2(Fn_cons,CAR(l1),nil);
  134.   STACK_TMP(val);
  135.   endptr = val;
  136.   walker = CDR(ARG_0(stackbase)/*l1*/);
  137.   while (is_cons(walker))
  138.     {
  139.       LispObject xx;
  140.       STACK_TMP(endptr);
  141.       STACK_TMP(CDR(walker));
  142.       xx = EUCALL_2(Fn_cons, CAR(walker), nil);
  143.       UNSTACK_TMP(walker);
  144.       UNSTACK_TMP(endptr);
  145.       CDR(endptr)=xx;
  146.       endptr=CDR(endptr);
  147.     }
  148.   CDR(endptr) = ARG_1(stackbase)/*l2*/;
  149.   UNSTACK_TMP(val);
  150.   return(val);
  151. }
  152. EUFUN_CLOSE
  153.  
  154.                 /* Simple predicate for NULL */
  155. EUFUN_1( Fn_lastpair, form)
  156. {
  157.   while (!is_cons(form))
  158.     form = CallError(stacktop,"Not a list in last-pair",form,CONTINUABLE);
  159.   while (is_cons(form) && CDR(form)!=nil)
  160.     form = CDR(form);
  161.   return form;
  162. }
  163. EUFUN_CLOSE
  164.  
  165. EUFUN_1( Fn_nreverse, form)
  166. {
  167.   LispObject x=nil;
  168.   while (form!=nil) {
  169.     LispObject y = CDR(form);
  170.     CDR(form) = x;
  171.     x = form;
  172.     form = y;
  173.   }
  174.   return x;
  175. }
  176. EUFUN_CLOSE
  177.  
  178. EUFUN_3( Fn_assoc, obj, list, fn)
  179. {
  180.   while (list!=nil) {
  181.     LispObject xx;
  182.     EUCALLSET_3(xx,apply2,ARG_2(stackbase),ARG_0(stackbase),CAR(CAR(list)));
  183.     if (xx != nil)  {
  184.       list=ARG_1(stackbase);
  185.       return CAR(list);
  186.     }
  187.     list = ARG_1(stackbase);
  188.     list = CDR(list);
  189.     ARG_1(stackbase) = list;
  190.   }
  191.   return nil;
  192. }
  193. EUFUN_CLOSE
  194.  
  195. EUFUN_3( Fn_member, obj, list, fn)
  196. {
  197.   while (list!=nil) {
  198.     if (EUCALL_3(apply2,ARG_2(stackbase),ARG_0(stackbase),CAR(list)) != nil) {
  199.       return ARG_1(stackbase);
  200.     }
  201.     list = ARG_1(stackbase);
  202.     list = CDR(list);
  203.     ARG_1(stackbase) = list;
  204.   }
  205.   return nil;
  206. }
  207. EUFUN_CLOSE
  208.  
  209. EUFUN_2( Fn_memq,  obj, list)
  210. {
  211.   if (!is_cons(list) && list != nil)
  212.     CallError(stacktop,"memq: non-lists passed",list,NONCONTINUABLE);
  213.  
  214.   while (is_cons(list)) {
  215.     if (obj == CAR(list))
  216.       return(lisptrue);
  217.     else
  218.       list = CDR(list);
  219.   }
  220.   
  221.   return(nil);
  222. }
  223. EUFUN_CLOSE
  224.  
  225. /* ******************************************************************** */
  226. /*                            Lisp Mappers                              */
  227. /* ******************************************************************** */
  228.  
  229. static LispObject mapcar_apply_args(LispObject *stackbase, LispObject set)
  230. {
  231.   LispObject walker,res,ptr;
  232.   LispObject *stacktop=stackbase+1;
  233.  
  234.   ARG_0(stackbase)=nil;
  235.   res = nil; ptr = nil;
  236.  
  237.   walker = set;
  238.   while (is_cons(walker)) 
  239.     {
  240.       if (!is_cons(CAR(walker))) 
  241.     return(nil);
  242.  
  243.       STACK_TMP(CDR(walker));
  244.       if (ptr == nil)
  245.     {
  246.       EUCALLSET_2(res, Fn_cons,CAR(CAR(walker)),nil);
  247.       ARG_0(stackbase)=res;
  248.       ptr = res;
  249.     }
  250.       else
  251.     {
  252.       LispObject xx;
  253.       STACK_TMP(ptr);
  254.       EUCALLSET_2(xx, Fn_cons, CAR(CAR(walker)),nil);
  255.       UNSTACK_TMP(ptr);
  256.       CDR(ptr) = xx;
  257.       ptr = CDR(ptr);
  258.     }
  259.       UNSTACK_TMP(walker);
  260.     }
  261.   res=ARG_0(stackbase);
  262.   return(res);
  263. }
  264.  
  265. static LispObject mapcar_advance_lists(LispObject set)
  266. { 
  267.   LispObject walker = set;
  268.  
  269.   while (is_cons(walker)) {
  270.     CAR(walker) = CDR(CAR(walker));
  271.     walker = CDR(walker);
  272.   }
  273.   
  274.   return(set);
  275. }
  276.  
  277. EUFUN_3( Fn_mapcar, fn, l1, lists)
  278. {
  279.   LispObject flat_list_copy(LispObject *);
  280.   
  281.   if (!is_cons(l1) && l1 != nil)
  282.     CallError(stacktop,"mapcar: not a list",l1,NONCONTINUABLE);
  283.  
  284.   ARG_3(stackbase)=nil;
  285.   stacktop++;
  286.  
  287.   {
  288.     LispObject set,args;
  289.     LispObject res,ptr,val;
  290.     
  291.     /* More general... */
  292.  
  293.     EUCALLSET_1(set, flat_list_copy, lists);
  294.     EUCALLSET_2(set, Fn_cons,ARG_1(stackbase),set);
  295.  
  296.     res = nil; ptr = nil;
  297.       
  298.     while (TRUE) 
  299.       {
  300.  
  301.     /* Construct args to apply... */
  302.       
  303.     STACK_TMP(set);    
  304.     STACK_TMP(ptr);
  305.     if ((args = mapcar_apply_args(stacktop,set)) == nil) 
  306.       {    
  307.         res=ARG_3(stackbase);
  308.         return(res);
  309.       }
  310.     UNSTACK_TMP(ptr);
  311.     STACK_TMP(ptr);
  312.     EUCALLSET_2(val,module_mv_apply_1,ARG_0(stackbase),args);
  313.     UNSTACK_TMP(ptr);
  314.       
  315.     if (ptr == nil)
  316.       {
  317.         EUCALLSET_2(res, Fn_cons,val,nil);
  318.         ARG_3(stackbase)=res;
  319.         ptr = res;
  320.       }
  321.     else 
  322.       {
  323.         LispObject xx;
  324.         STACK_TMP(ptr);
  325.         EUCALLSET_2(xx, Fn_cons, val,nil);
  326.         UNSTACK_TMP(ptr);
  327.         CDR(ptr) = xx;
  328.         ptr = CDR(ptr);
  329.       }
  330.     UNSTACK_TMP(set);
  331.     mapcar_advance_lists(set);
  332.       }
  333.   }
  334.  
  335.   return(nil);
  336. }
  337. EUFUN_CLOSE
  338.  
  339. EUFUN_3( Fn_mapc, fn, l1, lists)
  340. {
  341.  
  342.   if (!is_cons(l1) && l1 != nil)
  343.     CallError(stacktop,"mapc: not a list",l1,NONCONTINUABLE);
  344.  
  345.   if (FALSE) {
  346.     ;
  347.   }
  348.   else {
  349.     LispObject set,args;
  350.     
  351.     /* More general... */
  352.  
  353.     EUCALLSET_1(set,flat_list_copy,lists);
  354.     EUCALLSET_2(set, Fn_cons,ARG_1(stackbase),set);
  355.  
  356.     while (TRUE) {
  357.       LispObject dummy;
  358.  
  359.       /* Construct args to apply... */
  360.  
  361.       STACK_TMP(set);
  362.       if ((args = mapcar_apply_args(stacktop,set)) == nil) {
  363.     return(nil);
  364.       }
  365.       UNSTACK_TMP(set);
  366.  
  367.       STACK_TMP(set);
  368.       EUCALL_2(module_mv_apply_1,ARG_0(stackbase),args);
  369.       UNSTACK_TMP(set);
  370.       mapcar_advance_lists(set);
  371.     }
  372.   }
  373.  
  374.   return(nil);
  375. }
  376. EUFUN_CLOSE
  377.  
  378. EUFUN_1( flat_list_copy, list)
  379. {
  380.   LispObject xx;
  381.   if (!is_cons(list)) return(nil);
  382.   EUCALLSET_1(xx, flat_list_copy, CDR(list));
  383.   return(EUCALL_2(Fn_cons, CAR(ARG_0(stackbase)),xx));
  384. }
  385. EUFUN_CLOSE
  386.   
  387.  
  388. EUFUN_1( Fn_atom, form)
  389. {
  390.   return (is_cons(form) ? nil : lisptrue);
  391. }
  392. EUFUN_CLOSE
  393.  
  394. EUFUN_1( Fn_consn, n)
  395. {
  396.   int i;
  397.   LispObject l = nil;
  398.  
  399.   for (i = intval(n); i > 0; --i) {
  400.     ARG_1(stacktop) = l;
  401.     ARG_0(stacktop) = nil;
  402.     l = Fn_cons(stacktop);
  403.   }
  404.  
  405.   return(l);
  406. }
  407. EUFUN_CLOSE
  408.  
  409.  
  410. /*
  411.  * Module initialisation...
  412.  */
  413.  
  414. #define LISTS_ENTRIES 21
  415. MODULE Module_lists;
  416. LispObject Module_lists_values[LISTS_ENTRIES];
  417.  
  418. void initialise_lists(LispObject* stacktop)
  419. {
  420.   extern LispObject generic_generic_convert;
  421.   LispObject get,set;
  422.  
  423.   open_module(stacktop,
  424.           &Module_lists,
  425.           Module_lists_values,
  426.           "lists",
  427.           LISTS_ENTRIES);
  428.  
  429.   (void) make_module_function(stacktop,"consp",Fn_consp,1);
  430.   (void) make_module_function(stacktop,"cons",Fn_cons,2); /* In allocate.c */
  431.   
  432.   get = make_module_function(stacktop,"car",Fn_car,1);
  433.   STACK_TMP(get);
  434.   set = make_unexported_module_function(stacktop,"car-updator",car_updator,2);
  435.   UNSTACK_TMP(get);
  436.   set_anon_associate(stacktop,get,set);
  437.  
  438.   get = make_module_function(stacktop,"cdr",Fn_cdr,1);
  439.   STACK_TMP(get);
  440.   set = make_unexported_module_function(stacktop,"cdr-updator",cdr_updator,2);
  441.   UNSTACK_TMP(get);
  442.   set_anon_associate(stacktop,get,set);
  443.  
  444.   (void) make_module_function(stacktop,"list-length",Fn_length,1);
  445.   (void) make_module_function(stacktop,"list",Fn_list,-1);
  446.  
  447.   (void) make_module_function(stacktop,"memq",Fn_memq,2);
  448.   (void) make_module_function(stacktop,"append",Fn_append,2);
  449.   (void) make_module_function(stacktop,"copy-list",flat_list_copy,1);
  450.   (void) make_module_function(stacktop,"null",Fn_null,1);
  451.   (void) make_module_function(stacktop,"nconc",Fn_nconc,2);
  452.   (void) make_module_function(stacktop,"last-pair",Fn_lastpair,1);
  453.   (void) make_module_function(stacktop,"nreverse",Fn_nreverse,1);
  454.   (void) make_module_function(stacktop,"assoc",Fn_assoc,3);
  455.   (void) make_module_function(stacktop,"member-list",Fn_member,3);
  456.   (void) make_module_function(stacktop,"mapcar",Fn_mapcar,-3);
  457.   (void) make_module_function(stacktop,"mapc",Fn_mapc,-3);
  458.   (void) make_module_function(stacktop,"atom",Fn_atom,1);
  459.   (void) make_module_function(stacktop,"consn", Fn_consn, 1);
  460.   close_module();
  461. }
  462.